home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1992 June: ROMin Holiday / ADC Developer CD (1992-06) (''ROMin Holiday'')_iso / Developer Connection - 06-1992.iso / Development Platforms / LISP Related / U. Mass AI & LISP Tools / MODULES / RULES / Rule-Build.lisp < prev    next >
Encoding:
Text File  |  1990-06-25  |  19.9 KB  |  415 lines  |  [TEXT/CCL ]
  1. ; (c) Copyright 1990 by University of Massachusetts. All rights reserved.
  2. ; This software was conceived, designed, and written by Dan Suthers 
  3. ; while supported by the National Science Foundation under grant number
  4. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  5. ; CA.  Partial support was also received from the Office of Naval Research
  6. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  7. ; Mr. Suthers created this software under his own initiative while in an 
  8. ; academic relationship with the University of Massachusetts.  The above
  9. ; copyright notice was a condition placed by University lawyers on approval
  10. ; of distribution of this software by Apple Computer, and is not meant to
  11. ; imply that this software was created in an employment or "work for hire"
  12. ; relationship between the University and Mr. Suthers.
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ; File:         Rule-Build.lisp
  15. ; Author:       Dan Suthers
  16. ; Created:      19-Oct-88 21:57:32
  17. ; Modified:     22-Jun-90 02:21:38 (Dan Suthers)
  18. ; Language:     Common Lisp
  19. ; Package:      RULE
  20. ;
  21. ; Description:  Rule-based reasoner built on the pattern matching facilities
  22. ;               of DNET.  Supports forward and backward reasoning.
  23. ;
  24. ;              This file contains only the definition of the SM type RULE, 
  25. ;              and functions to add rules to DNETs of rules, delete them,
  26. ;              and related tasks.  See Rule-Defs, Rule-Forward, and Rule-Back.
  27. ;              File RULES has documentation.
  28. ;
  29. ; (c) Copyright 1988, by Daniel D. Suthers
  30. ;                        Department of Computer and Information Science
  31. ;                        University of Massachusetts
  32. ;                        Amherst, Massachusetts 01003
  33. ;
  34. ; This software was conceived, designed, and written by Dan Suthers 
  35. ; while supported by the National Science Foundation under grant number
  36. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  37. ; CA.  Partial support was also received from the Office of Naval Research
  38. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  39. ; I wish to acknowledge the generous support of Beverly Woolf, who obtained 
  40. ; the above grants and encouraged me to pursue my own research interests in
  41. ; her lab.  This work would not have been possible without the resources and
  42. ; stimulating environment of the Computer and Information Science department.
  43. ;
  44. ; Permission to use, modify, and distribute this software is granted subject 
  45. ; to the following restrictions and understandings:
  46. ; 1. The file header, including this notice, shall be retained, and may be
  47. ;    extended to include documentation of modifications to the software.
  48. ; 2. This material is for nonprofit educational and research purposes only.
  49. ;    Users are requested, but not required, to inform Mr. Suthers of any 
  50. ;    noteworthy uses of this software.
  51. ; 3. Mr. Suthers and the University of Massachusetts make no warrantee or
  52. ;    representation that the operation of this software will be error free,
  53. ;    and are under no obligation to provide any services.
  54. ; 4. Any user of such software agrees to indemnify and hold harmless Mr.
  55. ;    Suthers and the University of Massachusetts from all claims arising 
  56. ;    out of the use or misuse of this software, or arising out of any 
  57. ;    accident, injury, or damage whatsoever, and from all costs, counsel
  58. ;    fees, and liabilities incurred in or about any such claim, action, or
  59. ;    proceeding brought thereon.
  60. ; 5. All materials and reports developed as a consequence of the use of 
  61. ;    this software shall duly acknowledge such use, in accordance with
  62. ;    the usual standards of acknowledging credit in academic research.
  63. ;
  64. ; Status: Working.
  65. ;
  66. ; Changes:
  67. ;   30-Dec-88 :DELETE added to forward rules.
  68. ;   25-Mar-89 :SEQ added; eliminated bogus prohibition of nested :AND.
  69. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  70.  
  71. (in-package :RULE)
  72.  
  73. (export '(
  74.           add-rule
  75.           add-all-rules
  76.           delete-rule
  77.  
  78.           rule
  79.           rule-antecedent
  80.           rule-consequent
  81.           rule-directions
  82.           
  83.           ))
  84.  
  85.  
  86. (require :MISC) ; UTILS for UNIQUE-SYMBOL
  87. (require :Rule-Defs)
  88.  
  89. (use-package :DNET)
  90.  
  91. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  92. ;;;
  93. ;;;                              DATA STRUCTURES
  94. ;;;
  95. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  96.  
  97. (sm:dst (RULE (:redefine T)
  98.               (:reusable nil)
  99.               (:sort-instances t)
  100.               (:before-edit (lambda (r) 
  101.                               (dolist (dnet (rule-interned-in (sm:gets 'rule r)))
  102.                                 (delete-rule r dnet))))
  103.               (:after-edit (lambda (r) 
  104.                              (dolist (dnet (rule-interned-in (sm:gets 'rule r)))
  105.                                (add-rule r dnet))))
  106.               (:comments "
  107.   Simple if-then pattern matching rules.  
  108.   VARIABLES are the same as DNET variables, namely, symbols in the ? package.
  109.   SPECIAL FORMS include:
  110.     (:AND <f1> ... <fn>) - If in the consequent, this is only for convienence, and the
  111.       rule is parsed into multiple rules.  If in the antecedent, forward and backward 
  112.       chaining tries to process each of <f1> ... <fn> in the order given.  Any :AND not
  113.       at top level in the consequent results in factoring of the consequent. This is 
  114.       logical conjunction.  SUPPORT does not short-circuit evaluation when :record-failure
  115.       is T.  This allows applications to identify `near misses', etc. 
  116.     (:SEQ <C1> .. <Cn>) - Like :AND, but is always short-circuited on failure, even 
  117.       when :record-failure is T.  (SEQuential conjunction.)
  118.     (:OR <f1> ... <fn>) - for convienence in the antecedent only. The rule will be
  119.       stored as multiple rules resulting from factoring out :OR.  Ignored in the 
  120.       consequent.
  121.     (:LISP <expr1> ... <exprN>) - Variables in the current bindings list are
  122.       lambda-bound, and the expressions are evaluated, as in PROGV, the last value 
  123.       being returned.  When the :LISP form occurs in the antecedent, the result of 
  124.       evaluation is used to determine success (whether forward or back chaining).  It 
  125.       is useful in the consequent when side effects are desired in forward chaining, 
  126.       and to insert the results of lisp evaluation in the consequent expression.  To 
  127.       enable both uses, the result of a :LISP at top level is ignored (not treated as 
  128.       a derived expression to be added to the data base dnet); while the result of a 
  129.       :lisp embedded in an expression is included in that expression when it is indexed
  130.       as a new datum.
  131.     (:BIND <var> <expr>) - Variables in <expr> are bound, it is evaluated, and the
  132.       result is bound to <var>, which must be a variable.  Useful in antecedent to
  133.       define variables used in consequent, eg. to prevent use of :LISP IN consequent
  134.       which needs to be matched to for backchaining.
  135.     (:DELETE <expr>) - Variables in <expr> are bound, and the expression is deleted 
  136.       from the active data base.  (Any truth maintenance activities will be up to the 
  137.       DELEXPR-HOOK of the DNET.)  Applies only to forward rules."))
  138.  
  139.   (ANTECEDENT nil 
  140.               :type list
  141.               :comments "
  142.     A list expression, which may include variables, :AND, :SEQ, :OR (all possibly 
  143.     embedded), :LISP, and/or :BIND.  Forms embedded in :AND and :OR must themselves be 
  144.     lists or contained in lists after parsing.")
  145.  
  146.   (CONSEQUENT nil 
  147.               :type list
  148.               :comments "
  149.     A list expression, which may include variables, :AND and :SEQ (possibly nested), 
  150.    :LISP, and/or :BIND.  Forms embedded in :and must be lists, unless the :and is also
  151.     embedded in a list after parsing.")
  152.  
  153.   (DIRECTIONS :both 
  154.              :type (member :forward :forward-unique :backward :both :both-unique)
  155.              :comments "
  156.     Which direction(s) to use the rule in. :FORWARD-UNIQUE and :BOTH-UNIQUE specify
  157.     that the rule will not be allowed to fire forward twice on the same bindings.  
  158.     This takes extra space to save a list of previous bindings, and time to check new 
  159.     bindings against it.  Note that rules whose consequents are simple expressions
  160.     to be added to a data base will not be allowed to add the same expression twice,
  161.     even if :FORWARD or :BOTH is specified. The only time you need :FORWARD-UNIQUE
  162.     is when the consequent has a :LISP form which you only want to be evaluated once 
  163.     on a given binding set.  There is no :backward-unique since backchaining does
  164.     not work on :lisp consequents.")
  165.  
  166.   (INTERNED-IN nil 
  167.                :type list
  168.                :comments "
  169.     List of DNETs the rule is interned (stored) in.  Updated automatically, but not 
  170.     declared :computed in case you want to store and change it.")
  171.  
  172.   (INFO nil 
  173.         :type list
  174.         :comments "
  175.     Association list of keys to arbitrary info needed by the application.")
  176.  
  177.   (COMMENTS "" :type string))
  178.  
  179. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  180. ;;;
  181. ;;;                      INTERNAL FUNCTIONS AND MACROS
  182. ;;;
  183. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  184. ;;; Little Helpers
  185.  
  186. (defun TREE-MEMBER (thing tree)
  187.   (declare (keyword thing) (optimize (safety 1) (space 2) (speed 3)))
  188.   (cond ((atom tree) (eq thing tree))
  189.         ((null tree) nil)
  190.         (t (or (tree-member thing (car tree))
  191.                (tree-member thing (cdr tree))))))
  192.  
  193. ;;;------------------------------------------------------------------------
  194. ;;; Rule Error Checking:
  195. ;;; - :antecedent and :consequent are consed to forms to indexpr, to distinuish
  196. ;;;   these patterns while matching.  This is why the factored forms must be lists:
  197. ;;;   DNET cannot store a dotted pair.
  198. ;;; - An :OR in a consequent won't be interpreted, so probably is an error.  But
  199. ;;;   I only WARN, since they may be in there for reference rather than for use 
  200. ;;;   (e.g. for rules manipulating rules).
  201.  
  202. (defun BAD-ANTECEDENT-FORMS (rule antecedent-forms)
  203.   (declare (symbol rule) (list antecedent-forms)
  204.            (optimize (safety 1) (space 2) (speed 3)))
  205.   (cond ((not (every #'listp antecedent-forms))
  206.          (cerror "Rule will not be added."
  207.                  "[DNET:ADD-RULE] Parsed antecedent of Rule ~S contains non-list: ~%~S"
  208.                  rule antecedent-forms)
  209.          t)
  210.         ((not (every #'dnet:not-a-dotted-list antecedent-forms))
  211.          (cerror "Rule will not be added."
  212.                  "[DNET:ADD-RULE] Rule ~S has illegal dotted list in antecedent:~%~S" 
  213.                  rule antecedent-forms)
  214.          t)
  215.         (t nil)))
  216. (proclaim '(inline bad-antecedent-forms))
  217.  
  218. (defun BAD-CONSEQUENT-FORMS (rule consequent-forms)
  219.   (declare (symbol rule) (list consequent-forms)
  220.            (optimize (safety 1) (space 2) (speed 3)))
  221.   (cond ((not (every #'listp consequent-forms))
  222.          (cerror "Rule will not be added."
  223.                  "[DNET:ADD-RULE] Parsed consequent of Rule ~S contains non-list: ~%~S"
  224.                  rule consequent-forms)
  225.          t)
  226.         ((not (every #'dnet:not-a-dotted-list consequent-forms))
  227.          (cerror "Rule will not be added."
  228.                  "[DNET:ADD-RULE] Rule ~S has illegal dotted list in consequent:~%~S"
  229.                  rule consequent-forms)
  230.          t)
  231.         (t nil)))
  232. (proclaim '(inline bad-consequent-forms))
  233.  
  234. (defun WARN-OF-OR-IN-CONSEQUENT (rule consequent-forms)
  235.   (when (some #'(lambda (form) (declare (list form) (inline tree-member))
  236.                  (tree-member :or form))
  237.             consequent-forms)
  238.     (warn "[DNET:ADD-RULE] :OR in consequent of Rule ~S won't be interpreted."
  239.           rule)
  240.     t))
  241. (proclaim '(inline warn-of-or-in-consequent))
  242.  
  243. ;;;------------------------------------------------------------------------
  244. ;;; Review of Rule Indexing Policy and Representation:
  245. ;;; - :or-factored antecedents  --forward-->  conjunct of :and-factored consequents
  246. ;;; - :and-factored consequents --backward--> disjunct of unfactored antecedents
  247. ;;; - If a pattern is already indexed, we union the implicit conjunct/disjunct lists
  248. ;;;   to be mapped to.  This allows multiple rules to address the same data.
  249. ;;; - Each member of the implicit conjunct/disjunct indexed to is a rule record, 
  250. ;;;   recording among other things the rule which generated it (the warrant) and 
  251. ;;;   the consequent/antecedent mapped to.
  252. ;;; - Care should be taken to place conjuncts/disjuncts in the same order in this
  253. ;;;   list as they were in the original unfactored rule.
  254.  
  255. (defun ADD-RULE-INTERNAL (rule dnet)
  256.   (declare (symbol rule dnet) 
  257.            (function factor unique-variable-substitutions index-rule)
  258.            (optimize (safety 1) (space 2) (speed 3)))
  259.   
  260.   (defun FACTOR (operator pattern &aux (results (list :head)))
  261.     ;; Returns a list of expressions which have been factored by <operator>, eg:
  262.     ;; (factor :and '(:and (:and a b) (:and (foo c) d))) => (a b (foo c) d))
  263.     (declare (keyword operator) (list results))
  264.     (cond ((null pattern) (nconc results (list nil)))
  265.           ((atom pattern) (nconc results (list pattern)))
  266.           ((eq operator (first pattern))
  267.            (dolist (pat (rest pattern))
  268.              (nconc results (factor operator pat))))
  269.           (t
  270.            (dolist (car-factor (factor operator (car pattern)))
  271.              (dolist (cdr-factor (factor operator (cdr pattern)))
  272.                (nconc results (list (cons car-factor cdr-factor)))))))
  273.     (cdr results))
  274.   
  275.   (defun UNIQUE-VARIABLE-SUBSTITUTIONS (form)
  276.     ;; Returns a binding list which represents a substitution which should be
  277.     ;; done to result in an expression using unique variables.
  278.     (mapcar #'(lambda (var &aux new-var)
  279.                 (declare (symbol var new-var))
  280.                 (setq new-var 
  281.                       (utils:unique-symbol (format nil "~A." var) *?-package*))
  282.                 (export new-var *?-package*)
  283.                 (cons var new-var))
  284.             (variables-in-pattern form)))
  285.   
  286.   (defun INDEX-RULE (dnet key index-forms info-forms)
  287.     ;; Indexes each of <index-forms> into <dnet>, with <info-forms> recorded
  288.     ;; as info.  <Key> is consed onto each <index-form> for indexing.  If a
  289.     ;; collision occurs on indexing, unions the <info-form>s.
  290.     (declare (symbol dnet) (keyword key) (list index-forms info-forms))
  291.     (dolist (index-form index-forms) 
  292.       (declare (list index-form))
  293.       (multiple-value-bind
  294.         (newly-added terminal)
  295.         ;; Don't use template, so stored expression is not altered with template.
  296.         (dnet::indexpr-internal (cons key index-form) dnet info-forms)
  297.         (unless newly-added
  298.           (setf (dnet-terminal-info terminal)
  299.                 ;; Destructive safe since fresh list made by mapcar and list below.
  300.                 (nunion info-forms
  301.                         (dnet-terminal-info terminal) 
  302.                         :test #'(lambda (r1 r2)
  303.                                   (declare (list r1) (list r2))
  304.                                   (and (eq (rule-record-rule-name r1)
  305.                                            (rule-record-rule-name r2))
  306.                                        (equal (rule-record-pattern r1)
  307.                                               (rule-record-pattern r2))))))))))
  308.  
  309.   ;; The body of ADD-RULE-INTERNAL:
  310.   (let* ((rule-struct (sm:gets 'rule rule))
  311.          (substitutions
  312.           (unique-variable-substitutions
  313.            (append (rule-antecedent rule-struct) (rule-consequent rule-struct))))
  314.          (unique-antecedent
  315.           (substitute-bindings substitutions (rule-antecedent rule-struct)))
  316.          (unique-consequent
  317.           (substitute-bindings substitutions (rule-consequent rule-struct)))
  318.          (antecedent-forms (factor ':or  unique-antecedent))
  319.          (consequent-forms (mapcan #'(lambda (form) (factor ':seq form))
  320.                                    (factor ':and unique-consequent))))
  321.     (declare (list substitutions unique-antecedent unique-consequent
  322.                    antecedent-forms consequent-forms))
  323.     (cond
  324.      ((bad-antecedent-forms rule antecedent-forms) nil)
  325.      ((bad-consequent-forms rule consequent-forms) nil)
  326.      (T
  327.       (warn-of-or-in-consequent rule consequent-forms)
  328.       (case (rule-directions rule-struct)
  329.         ((:both)
  330.          (index-rule dnet :antecedent antecedent-forms
  331.                      (mapcar #'(lambda (c) (make-rule-record rule c nil))
  332.                              consequent-forms))
  333.          (index-rule dnet :consequent consequent-forms 
  334.                      (list (make-rule-record rule unique-antecedent nil))))
  335.         ((:forward)
  336.          (index-rule dnet :antecedent antecedent-forms
  337.                      (mapcar #'(lambda (c) (make-rule-record rule c nil))
  338.                              consequent-forms)))
  339.         ((:forward-unique)
  340.          (index-rule dnet :antecedent antecedent-forms
  341.                      (mapcar #'(lambda (c) (make-rule-record rule c t))
  342.                              consequent-forms)))
  343.         ((:backward)
  344.          (index-rule dnet :consequent consequent-forms 
  345.                      (list (make-rule-record rule unique-antecedent nil)))))
  346.       (pushnew dnet (rule-interned-in (sm:gets 'rule rule)))
  347.       rule))))
  348.  
  349. (defun DELETE-RULE-INTERNAL (rule dnet)
  350.   ;; This has to take the brute-force approach, since we don't know what
  351.   ;; variable replacement was done to uniquify it.
  352.   (declare (symbol rule dnet) (optimize (safety 1) (space 2) (speed 3)))
  353.   (map-dnet-terminals 
  354.    #'(lambda (terminal)
  355.        ;; When we get a terminal which references this rule ...
  356.        (when (member rule (dnet-terminal-info terminal)
  357.                      :key #'rule-record-rule-name)
  358.          ;; ... remove all rule-records belonging to this rule ...
  359.          (setf (dnet-terminal-info terminal)
  360.                (delete rule (dnet-terminal-info terminal) 
  361.                        :key #'rule-record-rule-name))
  362.          ;; .. if there are no more rule records, unindex the entry.
  363.          (unless (dnet-terminal-info terminal)
  364.            (dnet::delexpr-internal (dnet-terminal-expr terminal) dnet))))
  365.    dnet))
  366.  
  367. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  368. ;;;
  369. ;;;                        USER INTERFACE FUNCTIONS
  370. ;;;
  371. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  372.  
  373. (defun ADD-RULE (rule dnet)
  374.   "add-rule <rule> <dnet>                                           [Function]
  375.   The <rule> should be the symbolic name of an SM rule instance, and <dnet>
  376.   the name of a dnet. The rule will be added to the <dnet>, possibly after 
  377.   some rule transformations on :and and :or.  <Rule> is returned."
  378.   (declare (inline add-rule-internal))
  379.   (check-type rule symbol)
  380.   (check-type dnet symbol)
  381.   (assert (sm:gets 'rule rule) (rule) "[DNET:ADD-RULE] ~S is not a known RULE." rule)
  382.   (assert (sm:gets 'dnet dnet) (dnet) "[DNET:ADD-RULE] ~S is not a known DNET." dnet)
  383.   ;; Further error checking done in here after parsing the antecedent and consequent.
  384.   (add-rule-internal rule dnet))
  385.  
  386. (defun ADD-ALL-RULES ()
  387.   "add-all-rules                                                    [Function]
  388.   Adds all known rules to the DNETs specified in their INTERNED-IN slots.
  389.   If a DNET does not exist, continuable error allows user to create it."
  390.   (dolist (r (sm:instances 'rule))
  391.     (dolist (dnet (rule-interned-in (sm:gets 'rule r)))
  392.       (if (sm:gets 'dnet dnet)
  393.         (add-rule r dnet)
  394.         (progn
  395.           (cerror "Will make a plain-vanilla DNET by that name."
  396.                   "[DNET:ADD-ALL-RULES] ~S is not a known DNET." dnet)
  397.           (make-dnet dnet)
  398.           (add-rule r dnet))))))
  399.  
  400. (defun DELETE-RULE (rule dnet) 
  401.   "delete-rule <rule> <dnet>                                        [Function]
  402.   Undoes effects of ADD-RULE."
  403.   (declare (inline delete-rule-internal))
  404.   (check-type rule symbol)
  405.   (check-type dnet symbol)
  406.   (assert (sm:gets 'rule rule) (rule) 
  407.           "[DNET:DELETE-RULE] ~S is not a known RULE." rule)
  408.   (assert (sm:gets 'dnet dnet) (dnet) 
  409.           "[DNET:DELETE-RULE] ~S is not a known DNET." dnet)
  410.   (delete-rule-internal rule dnet))
  411.  
  412. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  413. (provide :rule-build)
  414. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  415. ;;; the end.